home *** CD-ROM | disk | FTP | other *** search
/ Magnum One / Magnum One (Mid-American Digital) (Disc Manufacturing).iso / d18 / intrfc61.arc / NAMELIST.PAS < prev    next >
Pascal/Delphi Source File  |  1991-03-28  |  19KB  |  682 lines
  1. {$N+}
  2. unit namelist;
  3. { These are the routines that print the name definitions }
  4.  
  5. interface
  6.  
  7. uses
  8.   dump,util,globals,loader,head,nametype;
  9.  
  10. var
  11.   last_kind : byte;
  12.   in_function : boolean;
  13.  
  14. procedure print_name_list(obj_list:list_ptr);
  15. procedure print_obj(obj:obj_ptr);
  16. procedure write_type_def(def:type_def_ptr);
  17. procedure write_type_info(var name:string; obj:obj_ptr; info:type_info_ptr);
  18. function find_type(unit_rec:unit_list_ptr;def_ofs:word):obj_ptr;
  19. procedure write_var_type(type_unit,type_def_ofs:word);
  20. procedure write_var_info(var name:string; info:var_info_ptr);
  21. procedure write_args(arg:arg_ptr; num_args:word);
  22. procedure write_proc_type(var name:string; flags:code_flags; info:func_type_ptr);
  23. procedure write_proc_info(var name:string; info:func_info_ptr);
  24. procedure write_const_info(var name:string; info:const_info_ptr);
  25. procedure write_general(kind:byte; title,name,suffix:string);
  26. function find_name(unit_rec:unit_list_ptr;info_ofs:word):string;
  27. {  Unreliable way to get a name from a pointer to its info }
  28.  
  29. implementation
  30.  
  31. uses
  32.   blocks;
  33.  
  34. const
  35.   semicrlf = ';'+^M+^J;
  36.  
  37. function obj_ofs(obj:pointer):word;
  38. begin
  39.   obj_ofs := ptr_diff(obj,buffer);
  40. end;
  41.  
  42. procedure write_type_def(def:type_def_ptr);
  43. var
  44.   i : integer;
  45.   l : longint;
  46.   save_kind : byte;
  47.   field_list : list_ptr;
  48.   current : list_ptr;
  49.   obj : obj_ptr;
  50.   no_name : string;
  51.   save_in_array : boolean;
  52. begin
  53.   with def^ do
  54.   begin
  55.     if base_type in [1,2,4,6,8,$a,$e,$f,$10,$11,$12,$13,$15,$18,$1a,$1b] then
  56.       case base_type of
  57.         1 : write('untyped');
  58.         2 : write('shortint');
  59.         4 : write('integer');
  60.         6 : write('longint');
  61.         8 : write('byte');
  62.        $a : write('word');
  63.        $e : write('single');
  64.        $f : write('double');
  65.       $10 : write('extended');
  66.       $11 : write('real');
  67.       $12 : write('boolean');
  68.       $13 : write('char');
  69.       $15 : write('comp');
  70.       $18 : write('text');
  71.       $1a : write('pointer');
  72.       $1b : write('string');
  73.     end
  74.     else
  75.     begin
  76.       if base_type <> 0 then
  77.         write('{ unrecognized base type ',hexbyte(base_type),'}');
  78.       case type_type of
  79.         0 : write('untyped');
  80.         1 : begin                  {Array}
  81.               write('array[');
  82.               write_var_type(index_unit,index_ofs);
  83.               write('] of ');
  84.               write_var_type(element_unit,element_ofs);
  85.             end;
  86.         2 : begin                  {Record}
  87.               save_kind := last_kind;
  88.               last_kind := record_id;
  89.               writeln ('Record ');
  90.  
  91.               build_list(field_list,buffer,add_offset(buffer,hash_ofs));
  92.  
  93.               current := field_list;
  94.               inc(indentation,2);
  95.               while current^.offset < $ffff do
  96.               begin
  97.                 obj := add_offset(buffer,current^.offset);
  98.                 print_obj(obj);
  99.                 current := current^.next;
  100.               end;
  101.               dec(indentation);
  102.               indent;
  103.               dec(indentation);
  104.               write('end');
  105.               last_kind := save_kind;
  106.             end;
  107.  
  108.         3 : begin                  {Object}
  109.               save_kind := last_kind;
  110.               last_kind := object_id;
  111.               write ('Object');
  112.               if parent_unit <> 0 then
  113.               begin
  114.                 write('(');
  115.                 write_var_type(parent_unit,parent_ofs);
  116.                 write(')');
  117.               end;
  118.               write(tab,'{ vmt block ',hexword(handle));
  119.               if w10 <> 0 then
  120.                 write(' w10=',hexword(w10));
  121.               writeln('}');
  122.  
  123.               build_list(field_list,buffer,add_offset(buffer,hash_ofs));
  124.  
  125.               inc(indentation,2);
  126.               current := field_list;
  127.               while current^.offset < $ffff do
  128.               begin
  129.                 obj := add_offset(buffer,current^.offset);
  130.                 print_obj(obj);
  131.                 current := current^.next;
  132.               end;
  133.               dec(indentation);
  134.               indent;
  135.               write('end');
  136.               dec(indentation);
  137.               last_kind := save_kind;
  138.             end;
  139.  
  140.         4 : begin                  {File}
  141.               write('file');
  142.               if base_unit <> 0 then
  143.               begin
  144.                 write(' of ');
  145.                 write_var_type(base_unit,base_ofs);
  146.               end;
  147.             end;
  148.         5 : write('built-in text type');
  149.         6 : begin                  {function/procedure}
  150.               no_name := '';
  151.               write_proc_type(no_name,[],func_type_ptr(addr(return_ofs)));
  152.               writeln;
  153.             end;
  154.         7 : begin                  {Set}
  155.               write('set of ');
  156.               write_var_type(base_unit,base_ofs);
  157.             end;
  158.         8 : begin                  {Pointer}
  159.               write('^');
  160.               write_var_type(target_unit,target_ofs);
  161.             end;
  162.  
  163.         9 : begin                  {String}
  164.               write('string[',size-1,']');
  165.               {N.B. actually record is like array of char, but "string" with
  166.                     no length is different.}
  167.             end;
  168.        10 : write('built-in ',size,' byte 8087 type');    {8087}
  169.        11 : write('built-in 6-byte real');
  170.        12 : begin                  {Range}
  171.               write(lower,'..',upper);
  172.             end;
  173.        13 : write('built-in boolean');
  174.        14 : write('built-in char type');
  175.        15 : begin                  {Enumeration or subrange}
  176.               if (type_unit = unit_list[1]^.own_record)
  177.                  and (type_ofs = obj_ofs(def)) then
  178.               begin
  179.                 { Must be first definition }
  180.                 write('(');
  181.                 {  Assume following records are constant declarations  }
  182.                 obj := add_offset(def,30);
  183.                 for l:=lower to upper-1 do
  184.                 begin
  185.                   write(obj^.name,',');
  186.                   obj:=add_offset(obj,12+length(obj^.name));
  187.                 end;
  188.                 write(obj^.name,')');
  189.               end
  190.               else
  191.               begin
  192.                 { Must be subrange }
  193.                 obj := add_offset(get_unit(type_unit)^.buffer,type_ofs);
  194.                 obj := add_offset(obj,24);
  195.                 i := 0;
  196.                 while i < def^.lower do
  197.                 begin
  198.                   obj:=add_offset(obj,12+length(obj^.name));
  199.                   inc(i);
  200.                 end;
  201.                 write(obj^.name);
  202.                 while i < def^.upper do
  203.                 begin
  204.                   obj:=add_offset(obj,12+length(obj^.name));
  205.                   inc(i);
  206.                 end;
  207.                 write('..',obj^.name);
  208.               end;
  209.             end;
  210.        else
  211.             begin
  212.               writeln('Type definition of type ',type_type, 'otherbyte=',
  213.                       other_byte,'size=',size);
  214.               indent;
  215.               write(' junk=');
  216.               for i:=3 to 8 do
  217.                 write(who_knows[i]:6);
  218.               writeln;
  219.             end;
  220.       end;
  221.     end;
  222.   end;
  223. end;
  224.  
  225. procedure write_type_info(var name:string; obj:obj_ptr; info:type_info_ptr);
  226. var
  227.   def_obj : obj_ptr;
  228. begin
  229.   indent;
  230.   if (last_kind <> record_id) and (last_kind <> type_id) then
  231.   begin
  232.     writeln('type');
  233.     indent;
  234.     last_kind := type_id;
  235.   end;
  236.   write(oneindent,name,'=',oneindent);
  237.   with info^ do
  238.     if obj = find_type(get_unit(type_unit),type_def_ofs) then
  239.       write_type_def(add_offset(buffer,type_def_ofs))
  240.     else
  241.       write_var_type(type_unit,type_def_ofs);
  242.   writeln(';');
  243. end;
  244.  
  245. function find_type(unit_rec:unit_list_ptr;def_ofs:word):obj_ptr;
  246. var
  247.   current:list_ptr;
  248.   obj : obj_ptr;
  249.   obj_info : type_info_ptr;
  250. begin
  251.   with unit_rec^ do
  252.   begin
  253.     if (obj_list = nil) and (buffer <> nil) then
  254.       build_list(obj_list,buffer,add_offset(buffer,header_ptr(buffer)^.ofs_hashtable));
  255.     if obj_list <> nil then
  256.     begin
  257.       current := obj_list;
  258.       while current^.offset < $ffff do
  259.       begin
  260.         obj := add_offset(buffer,current^.offset);
  261.         obj_info := add_offset(obj,4+length(obj^.name));
  262.         if     (obj^.obj_type = type_id)
  263.            and (obj_info^.type_def_ofs = def_ofs)
  264.            and (obj_info^.type_unit = own_record) then
  265.         begin
  266.           find_type := obj;
  267.           exit;
  268.         end;
  269.         current := current^.next;
  270.       end;
  271.     end;
  272.     find_type := nil;
  273.   end;
  274. end;
  275.  
  276. function find_name(unit_rec:unit_list_ptr;info_ofs:word):string;
  277. {  Unreliable way to get a name from a pointer to its info }
  278. var
  279.   i:word;
  280.   name:string;
  281. begin
  282.   with unit_rec^ do
  283.   begin
  284.     if buffer <> nil then
  285.       for i:=info_ofs-2 downto 0 do
  286.         if i+buffer^[i]+1 = info_ofs then
  287.         begin
  288.           move(buffer^[i],name[0],buffer^[i]+1);
  289.           find_name := name;
  290.           exit;
  291.         end;
  292.   end;
  293.   find_name := '';
  294. end;
  295.  
  296. procedure write_var_type(type_unit,type_def_ofs:word);
  297. var
  298.   type_obj : obj_ptr;
  299.   unit_ptr : unit_list_ptr;
  300. begin
  301.   if type_unit > 0 then
  302.   begin
  303.     unit_ptr := get_unit(type_unit);
  304.     with unit_ptr^ do
  305.     begin
  306.       if buffer <> nil then
  307.       begin
  308.         type_obj := find_type(unit_ptr,type_def_ofs);
  309.         if type_obj <> nil then
  310.           write(type_obj^.name)
  311.         else
  312.           write_type_def(add_offset(buffer,type_def_ofs));
  313.       end
  314.       else
  315.         write(name,'.ofs',type_def_ofs);
  316.     end;
  317.   end
  318.   else
  319.     write('type_unit not found');
  320. end;
  321.  
  322. procedure write_var_info(var name:string; info:var_info_ptr);
  323. var
  324.   orig_unit:unit_list_ptr;
  325.   f : var_flags;
  326. begin
  327.   indent;
  328.   with info^ do
  329.   begin
  330.     if not (last_kind in [object_id,objpriv_id,record_id]) then
  331.     begin
  332.       f := flags*[const_flag,local,referenced];
  333.       if f = [] then
  334.         write_general(var_id,'var',name,':'+oneindent)
  335.       else if f = [const_flag] then
  336.         write_general(const_id,'const',name,':'+oneindent)
  337.       else if f = [local] then
  338.         write_general(local_id,'local var',name,':'+oneindent)
  339.       else if f = [local,referenced] then
  340.         write_general(referenced_id,'referenced var',name,':'+oneindent)
  341.       else
  342.         write('{ var flags = ',hexbyte(byte(flags)),'}'+oneindent);
  343.       end
  344.     else
  345.       write(name,':',oneindent);
  346.  
  347.     write_var_type(type_unit,type_def_ofs);
  348.  
  349.     if absolute in flags then
  350.     begin
  351.       write(' absolute ');
  352.       orig_unit := get_unit(in_unit);
  353.       if orig_unit <> nil then
  354.       begin
  355.         if orig_unit <> unit_list[1] then
  356.           write(orig_unit^.name,'.');
  357.         writeln(find_name(orig_unit,offset),';');
  358.       end
  359.       else
  360.         writeln('?????;');
  361.     end
  362.     else
  363.     begin
  364.       if const_flag in flags then
  365.         write('=',oneindent,'?');
  366.       if in_function then
  367.         write(';',tab,'{BP ofs ',integer(offset))
  368.       else
  369.       begin
  370.         write(';',tab,'{ofs ',hexword2(offset));
  371.         if not (last_kind in [record_id,object_id,objpriv_id]) then
  372.           write(' in block ',hexword2(in_unit));
  373.       end;
  374.       writeln('}');
  375.     end;
  376.   end;
  377. end;
  378.  
  379. procedure write_args(arg:arg_ptr;num_args:word);
  380. var
  381.   i:word;
  382. begin
  383.   writeln('(');
  384.   inc(indentation);
  385.   for i:=1 to num_args do
  386.   begin
  387.     with arg^ do
  388.     begin
  389.       indent;
  390.       if referenced in flags then
  391.         write('var ')
  392.       else
  393.         write('    ');
  394.       if flags - [referenced] <> [local] then
  395.       begin
  396.         writeln('{ flags =',hexbyte(byte(flags)),' }');
  397.         indent;
  398.       end;
  399.       write('arg',i,':',oneindent);
  400.       write_var_type(type_unit,type_def_ofs);
  401.       writeln(';');
  402.     end;
  403.     arg := add_offset(arg,sizeof(arg_rec));
  404.   end;
  405.   indent;
  406.   write(')');
  407.   dec(indentation);
  408. end;
  409.  
  410. procedure write_locals(var name:string; info:func_info_ptr);
  411. var
  412.   obj_list : list_ptr;
  413.   save_in_function : boolean;
  414. begin
  415.   if info^.local_hash = 0 then
  416.     exit;
  417.   save_in_function := in_function;
  418.   in_function := true;
  419.   build_list(obj_list,buffer,add_offset(buffer,info^.local_hash));
  420.   inc(indentation);
  421.   indent; writeln('{ ',name,' locals begin...}');
  422.   print_name_list(obj_list);
  423.   indent; writeln('{ ...',name,' locals end.}');
  424.   writeln;
  425.   dec(indentation);
  426.   in_function := save_in_function;
  427. end;
  428.  
  429.  
  430. procedure write_proc_type(var name:string; flags:code_flags; info:func_type_ptr);
  431. var
  432.   proc : boolean;
  433. begin
  434.   with info^ do
  435.   begin
  436.     if (type_def_ofs = 0) and (type_unit = 0) then
  437.       proc := true
  438.     else
  439.       proc := false;
  440.     if construct in flags then
  441.       write('constructor',oneindent,name)
  442.     else if destruct in flags then
  443.       write('destructor',oneindent,name)
  444.     else
  445.       if proc then
  446.         write('procedure',oneindent,name)
  447.       else
  448.         write('function',oneindent,name);
  449.     if info^.num_args > 0 then
  450.       write_args(arg_ptr(add_offset(info,sizeof(func_type_rec))),
  451.                  info^.num_args);
  452.     if not proc then
  453.     begin
  454.       write(':',oneindent);
  455.       write_var_type(type_unit,type_def_ofs);
  456.     end;
  457.   end;
  458.   write(';');
  459. end;
  460.  
  461. procedure write_proc_info(var name:string; info:func_info_ptr);
  462. var
  463.   entry_pt : entry_pt_ptr;
  464.   code : ^word;
  465.   i : word;
  466. begin
  467.   indent;
  468.   with info^ do
  469.   begin
  470.     if b2 <> 0 then
  471.       write(' { b2 = ',hexbyte(b2),'} ');
  472.     write_proc_type(name,code_type,func_type_ptr(addr(func_type)));
  473.     if vmt_entry > 0 then
  474.       write(' virtual;');
  475.     if external_code in code_type then
  476.       write(' external;');
  477.     if assembler in code_type then
  478.       write(' assembler;');
  479.     if not (inline_code in code_type) then
  480.     begin
  481.       entry_pt := add_offset(buffer,header^.ofs_entry_pts+entry_ofs);
  482.       writeln(tab,'{ Proc ',hexword2(entry_ofs),
  483.                   ' Entry ',hexword2(entry_pt^.code_block),':',
  484.                             hexword(entry_pt^.offset),'}');
  485.     end;
  486.     if inline_code in code_type then
  487.     begin
  488.       writeln;
  489.       indent;
  490.       write(' Inline(');
  491.       code := add_offset(info,sizeof(func_info_rec)
  492.                              +func_type.num_args*sizeof(arg_rec));
  493.       for i:=1 to entry_ofs div 2 - 1 do
  494.       begin
  495.         write('$',hexbyte(hi(code^)):2,'/');
  496.         if lo(code^) <> 0 then
  497.           writeln('Low byte not zero!');
  498.         code := add_offset(code,sizeof(word));
  499.       end;
  500.       writeln('$',hexbyte(hi(code^)):2,');');
  501.       if lo(code^) <> 0 then
  502.         writeln('Low byte not zero!');
  503.     end;
  504.     if f4 in code_type then
  505.       writeln('Unknown flag f4 in code_type');
  506.     if do_locals in active_options then
  507.       write_locals(name,info);
  508.   end;
  509. end;
  510.  
  511. procedure write_const_info(var name:string; info:const_info_ptr);
  512. var
  513.   type_obj : obj_ptr;
  514. begin
  515.   indent;
  516.   if (last_kind <> record_id) and (last_kind <> const_id) then
  517.   begin
  518.     writeln('Const');
  519.     indent;
  520.     last_kind := const_id;
  521.   end;
  522.   write(oneindent,name,'=',oneindent);
  523.   with info^,get_unit(type_unit)^ do
  524.   begin
  525.     if name = 'SYSTEM' then
  526.     case type_def_ofs of
  527.                 { Risky to fix these, but can't see any
  528.                                   other way to type constants }
  529.         $a0:   write('''',stringval,'''');
  530.         $c0:   write(extendval);
  531.        $114:   write(intval);
  532.        $130:   write(boolval);
  533.        $14c:   write('''',charval,'''');
  534.  
  535.         else
  536.           write('?');
  537.     end
  538.     else
  539.       write('?');
  540.   end;
  541.   writeln(';');
  542. end;
  543.  
  544. procedure write_unit_info(var name:string; info:unit_ptr; self:boolean);
  545. begin
  546.   indent;
  547.   if self then
  548.   begin
  549.     write('Unit',oneindent,name,';');
  550.     last_kind := init_id;
  551.   end
  552.   else
  553.   begin
  554.     if last_kind = unit_id then
  555.       write(oneindent,',',name)
  556.     else
  557.     begin
  558.       write('Uses',oneindent,name);
  559.       last_kind := unit_id;
  560.     end;
  561.   end;
  562.   with info^ do
  563.   begin
  564.     writeln(tab,'{ checksum = ',hexword(checksum),'}');
  565.   end;
  566. end;
  567.  
  568. procedure write_general(kind:byte; title,name,suffix:string);
  569. begin
  570.   if last_kind <> kind then
  571.   begin
  572.     writeln(title);
  573.     last_kind := kind;
  574.     indent;
  575.   end;
  576.   write(oneindent,name,suffix);
  577. end;
  578.  
  579. procedure print_obj(obj:obj_ptr);
  580. var
  581.   j:word;
  582.   obj_info : ^byte_array;
  583.   new_entry : list_ptr;
  584.   info_len,info_ofs : word;
  585.   obj_type : byte;
  586. const
  587.   known_types : set of byte = [var_id,unit_id,const_id,type_id,proc_id,
  588.                                sys_proc_id,sys_fn_id,sys_mem_id,sys_port_id,
  589.                                sys_new_id];
  590.   dump_types  : set of byte = [];
  591. begin
  592.   info_ofs := sizeof(obj_rec)-sizeof(string)+1+length(obj^.name);
  593.   obj_info := add_offset(obj,info_ofs);
  594.   obj_type := obj^.obj_type;
  595.   if (obj_type and $80) <> 0 then
  596.   begin
  597.     if last_kind <> objpriv_id then
  598.     begin
  599.       dec(indentation);
  600.       indent;
  601.       inc(indentation);
  602.       writeln('private');
  603.       last_kind := objpriv_id;
  604.     end;
  605.     obj_type := obj_type and $7F;
  606.   end;
  607.  
  608.   if obj_type in known_types then
  609.   begin
  610.     if obj_type = unit_id then
  611.     begin
  612.       add_unit(obj^.name);
  613.       if unit_ptr(obj_info)^.target = 0 then
  614.         unit_ptr(obj_info)^.target := get_unit_num(obj^.name);
  615.              {  Save our ID there, so references can find the information  }
  616.     end;
  617.  
  618.     case obj_type of  { Strip private bit }
  619.        const_id : write_const_info(obj^.name,pointer(obj_info));
  620.        type_id : write_type_info(obj^.name,obj,pointer(obj_info));
  621.  
  622.        var_id  : write_var_info(obj^.name,pointer(obj_info));
  623.  
  624.        proc_id : begin
  625.                    write_proc_info(obj^.name,pointer(obj_info));
  626.                    if not (last_kind in [object_id,objpriv_id]) then
  627.                      last_kind := proc_id;
  628.                  end;
  629.  
  630.        sys_proc_id : write_general(sys_proc_id,'built-in procedure',obj^.name,semicrlf);
  631.  
  632.        sys_fn_id : write_general(sys_fn_id,'built-in function',obj^.name,semicrlf);
  633.  
  634.        sys_port_id : write_general(sys_port_id,'port array',obj^.name,semicrlf);
  635.  
  636.        sys_mem_id : write_general(sys_mem_id,'memory array',obj^.name,semicrlf);
  637.  
  638.        sys_new_id : write_general(sys_new_id,'system allocator',obj^.name,semicrlf);
  639.  
  640.        unit_id :   write_unit_info(obj^.name,pointer(obj_info),
  641.                      obj_ofs(obj) = header^.ofs_this_unit)
  642.  
  643.     end; {case}
  644.   end
  645.   else
  646.   begin
  647.     writeln('Unknown kind ',obj_type,oneindent,obj^.name,' with info at ',
  648.             hexword(obj_ofs(obj_info)));
  649.     last_kind := obj_type;
  650.   end;
  651.   if obj_type in dump_types then
  652.   begin
  653.     for j:=0 to 15 do
  654.       write(hexword(obj_ofs(obj_info)+j):5);
  655.     for j:=0 to 15 do
  656.       write(hexbyte(obj_info^[j]):5);
  657.     for j:=16 to 31 do
  658.       write(hexword(obj_ofs(obj_info)+j):5);
  659.     for j:=16 to 31 do
  660.       write(hexbyte(obj_info^[j]):5);
  661.   end;
  662. end;
  663.  
  664. procedure print_name_list(obj_list:list_ptr);
  665. var
  666.   obj : obj_ptr;
  667.   current : list_ptr;
  668.   bytes : ^byte_array;
  669.   j : integer;
  670. begin
  671.   last_kind := init_id;
  672.   current := obj_list;
  673.   while current^.offset < $ffff do
  674.   begin
  675.     obj := add_offset(buffer,current^.offset);
  676.     print_obj(obj);
  677.     current := current^.next;
  678.   end;
  679. end;
  680.  
  681. end.
  682.